home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Clone / redefs.f < prev    next >
Encoding:
FORTH Source  |  1992-05-29  |  3.6 KB  |  205 lines
  1. \ MOD: 7/21/90 Add >NAME
  2. \ 00002  06-aug-91  mdh  Added QUIT
  3.  
  4. \ Redefine words that behave differently when Cloned.
  5.  
  6. only forth definitions
  7.  
  8. ANEW task-redefs.f
  9.  
  10. VARIABLE RawExpectEcho
  11.  
  12. also TGT definitions
  13.  
  14. \ ----------------------------------------------------------------------
  15.  
  16. vocabulary redefs    also redefs definitions   previous
  17.  
  18. also redefs
  19. defer find   ' false is find
  20. previous
  21.  
  22. : ECHOTYPE       2drop      ;
  23.  
  24. : CLICOMMAND     CMDBlock @ ;
  25.  
  26. : DOSSTRING      DOSBlock @ ;
  27.  
  28. : .  (.) ;
  29.  
  30.  
  31. : BYE  ( -- )    ExitJForth  ;
  32.  
  33.  
  34. : (QUIT) ( -- )
  35.   what's ErrorCleanUp \ should ONLY be called from here!
  36.   ' noop dup is ErrorCleanUp  is UserCleanUp
  37.   execute  ExitJForth  ;
  38.  
  39. also redefs  \ 00002 -- ErrorCleanUp is what the user should set instead of
  40. defer QUIT  ' (quit) is quit   \  QUIT (<- for INTERPRETER use only)
  41. previous
  42.  
  43. : (INTERPRET)  ( -- )  ;
  44.  
  45.  
  46. : ?STACK  ( -- )  ;
  47.  
  48.  
  49. : WORD  ( char -- adr )
  50.   skip-word? @        ( -- char flag )
  51.   IF
  52.      drop
  53.   ELSE
  54.      parse-word       ( -- adr cnt )
  55.      here lplace
  56.   THEN
  57.   here dup count +    ( -- here last+1 )
  58.   bl swap c!          ( -- here )
  59.   skip-word? off
  60. ;
  61.  
  62.  
  63. : ?PAUSE  ( -- )  ;
  64.  
  65.  
  66. : >IS  ( pfa -- dataadr )  ( do-does-size ) DEFER-SIZE +  ;
  67.  
  68.  
  69. : DEFER-execute   @execute ;
  70.  
  71.  
  72. : (EXPECT)
  73.   what's emit >r   RawExpectEcho @ 0=
  74.   IF
  75.      ' drop is emit
  76.   THEN
  77.   (expect)
  78.   r> is emit  ;
  79.  
  80. : (?terminal)   ( -- flag )
  81.   ConsoleIn @ dup
  82.   IF
  83.      dup call dos_lib IsInteractive
  84.      IF
  85.         drop   (?terminal)
  86.      ELSE
  87.         dup fkey  ( -- fp key? )  EOF =
  88.         IF
  89.            drop 0
  90.         ELSE
  91.            ( -- fp )  -1 offset_current fseek drop  true
  92.         THEN
  93.      THEN
  94.   THEN
  95. ;
  96.  
  97. : (KEY)
  98.   ConsoleIn @
  99.   IF
  100.      flushemit
  101.      BEGIN
  102.         CancelNow?  (?terminal)  0=
  103.      WHILE
  104.         60,000 (?terminal.delay) drop
  105.      REPEAT
  106.      (key)
  107.   ELSE
  108.      false
  109.   THEN
  110. ;
  111.  
  112. global-defer KEY        also Redefs      ' (KEY)       is KEY        previous
  113. global-defer ?TERMINAL  also Redefs      ' (?TERMINAL) is ?TERMINAL  previous
  114.  
  115. : KH.EXPECT  ( addr max -- , expect for history )
  116.     (expect)
  117. ;
  118.  
  119. \ These two are from the Floating Point code.
  120. : SMUDGE0123 ;
  121. : UNSMUDGE0123 ;
  122.  
  123. : OB.CHECK.BIND  2drop  ;
  124.  
  125. : OB.BAD.METHOD quit ;
  126.  
  127. : CREATE ;
  128. : DOES> ;
  129.  
  130. global-defer :CREATE
  131. also redefs ' noop is :create  previous
  132.  
  133. : OB.SET.NAME  2drop ;
  134.  
  135. : TRAPS ;
  136. : NOTRAPS ;
  137. : UNRAVEL ;
  138.  
  139. \ vocabulary workarounds...
  140. also redefs definitions  only forth  \ lets make sure of where we are here!
  141.  
  142. : VOCDOES  drop ;
  143. : VLATEST>VLINK ;
  144. : VLINK>VLATEST ;
  145. : DEFINITIONS ;
  146. : ALSO ;
  147. : ONLY ;
  148. : SEAL ;
  149. : PREVIOUS ;
  150. : ORDER: ;
  151. : VOC-ID. drop ;
  152. : ORDER ;
  153. : FIND-IN false ;
  154. : VOC-FIND false ;
  155. : VOCS ;
  156. : VLIST ;
  157. : WORDS ;
  158. : SCAN-VOC drop ;
  159. : SCAN-WORDS ;
  160. : SCAN-ALL-VOCS ;
  161. : >NAME ( cfa -- nfa )
  162.     drop   " '>NAME inactive when Cloned!'" ;
  163.  
  164. only forth definitions
  165.  
  166. also TGT definitions
  167.  
  168.  
  169.  
  170. \ This vocabulary is searched IF TRACKING is false  (default)
  171.  
  172.  
  173. vocabulary AllocRedefs    also AllocRedefs definitions   previous
  174.  
  175. : ALLOCBLOCK  xallocblk  ;
  176. : FREEBLOCK   xfreeblk   ;
  177. : ExitFreeBlocks   noop  ;
  178. : ExitCloseFiles   noop  ;
  179. : ExitCloseLibs    noop  ;
  180. : BYEFREE>         drop  ;
  181. : >BYEFREE         drop  ;
  182. : BYECLOSE>        drop  ;
  183. : >BYECLOSE        drop  ;
  184. : MARKFREEBLOCK    drop  ;
  185. : UNMARKFREEBLOCK  drop  ;
  186. : MARKFCLOSE       drop  ;
  187. : UNMARKFCLOSE     drop  ;
  188.  
  189. only forth definitions
  190.  
  191. also TGT definitions
  192.  
  193. vocabulary IORedefs    also IORedefs definitions   previous
  194.  
  195. global-defer EMIT        also IORedefs    ' drop is EMIT        previous
  196. global-defer KEY        also IORedefs    ' EOL  is KEY        previous
  197. global-defer ?TERMINAL    also IORedefs    ' false is ?TERMINAL    previous
  198. global-defer FLUSHEMIT    also IORedefs    ' noop is FLUSHEMIT    previous
  199.  
  200. only forth definitions
  201.  
  202. : RedefsEnd ;
  203.  
  204. also TGT
  205.